# GNU Shepherd --- Test the #:file-creation-mask option of 'make-forkexec-constructor'.
# Copyright © 2020 Diego N. Barbato <dnbarbato@posteo.de>
#
# This file is part of the GNU Shepherd.
#
# The GNU Shepherd is free software; you can redistribute it and/or modify it
# under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 3 of the License, or (at
# your option) any later version.
#
# The GNU Shepherd is distributed in the hope that it will be useful, but
# WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with the GNU Shepherd.  If not, see <http://www.gnu.org/licenses/>.

shepherd --version
herd --version

socket="t-socket-$$"
conf="t-conf-$$"
log="t-log-$$"
pid="t-pid-$$"
failed="t-failed-$$"
success="t-success-$$"
service_log="t-service-log-$$"
service_new_file="t-service-new-file-$$"

herd="herd -s $socket"

# XX log
# $log $service_log $service_new_file;
trap "cat $log || true;
      rm -f $socket $conf
      test -f $pid && kill \`cat $pid\` || true; rm -f $pid" EXIT

function wait_for_file
{
    i=0
    while ! test -f "$1" && test $i -lt 40
    do
	sleep 0.3
	i=`expr $i + 1`
    done
    test -f "$1"
}

function wait_for_file2
{
    i=0
    while ! test -f "$1" && ! test -f "$2" && test $i -lt 40
    do
	sleep 0.3
	i=`expr $i + 1`
    done
    test -f "$1" || test -f "$2"
}

cat > "$conf"<<EOF

(use-modules (srfi srfi-1))

(define (test-code name ok-exp?)
  "Return a S-exp that, when evaluated,
touched \$failed-NAME if OK-EXP? evaluates
to #f. and \$ucces-NAME otherwise."
(quasiquote (let ()
     (define (fd-value fd)
       (read (fdes->inport fd)))
     (define (fd-exists? fd)
(pk 'poke fd       (catch 'system-error
         (lambda ()
	   (fcntl fd F_GETFD)
           #t)
         (lambda args
           (if (= (system-error-errno args) EBADF)
              #f
              (apply throw args))))))
     ;; Guile internally allocates some ports
     ((@@ (shepherd system) %set-automatic-finalization-enabled?!) #f)
     (unless (pk 'ok ,ok-exp?)
       (format #t "Failed: ~s~%" ',ok-exp?)
       (with-output-to-file
         (string-append "$PWD/$failed-" ,(symbol->string name))
         (const '()))
       (exit 0))
     (with-output-to-file
       (string-append "$PWD/$success-" ,(symbol->string name))
       (const '()))
     (exit 0))))

(define (command name ok-exp?)
  (list "$GUILE" "--use-srfi=1" "-e"
    (object->string (test-code name ok-exp?))))

(define (test-service name ok-exp? fd-mappings)
  (make <service>
    #:provides (list name)
    #:start (make-forkexec-constructor (command name ok-exp?)
    	    			       #:fd-mappings fd-mappings)
    #:stop (make-kill-destructor)
    #:respawn? #f))

(define* (port-with-sexp object cloexec)
  (let ((t (tmpfile)))
    (fcntl t F_SETFD
      (let ((old (fcntl t F_GETFD)))
        (if cloexec
          (logior old FD_CLOEXEC)
          (logand old (lognot FD_CLOEXEC)))))
    (write object t)
    t))

(register-services
  ;; Ports > 2 should be closed.
  ;; XXX apparently fd 3 is not close? Apparently it's a pipe.
  ;; Maybe Guile internally allocates a port?
  (test-service 'close-high-ports
    '(not (any identity (map fd-exists? (iota 20 4)))) '()))
EOF

rm -f "$pid"
rm -f "$$failed-close-high-ports" "$$success-close-high-ports"
shepherd -I -s "$socket" -c "$conf" -l "$log" --pid="$pid" &

# Wait till it's ready.
wait_for_file "$pid"

# Start the service.
$herd start close-high-ports
wait_for_file2 "$failed-close-high-ports" "$success-close-high-ports"
test -f "$success-close-high-ports"
